Lab 20 - Game Theory

Task 20.1.2

Write function to take matrix A and output probabilities

library(plotly)
library(tidyverse)
library(lpSolve)

solve_penalty_game <- function(A) {
  if (!is.matrix(A) || any(dim(A) != c(3, 3))) stop("A must be a 3x3 matrix")
  
  # Kicker LP: max v such that t(p) %*% A >= v, sum(p) = 1, p >= 0
  f.obj <- c(0, 0, 0, 1)
  f.con <- rbind(
    c(A[1, ], -1),
    c(A[2, ], -1),
    c(A[3, ], -1),
    c(1, 1, 1, 0)
  )
  f.dir <- c(">=", ">=", ">=", "==")
  f.rhs <- c(0, 0, 0, 1)
  result <- lp("max", f.obj, f.con, f.dir, f.rhs)
  #if (result$status != 0 || is.null(result$solution)) return(rep(NA, 7))
  q_star <- result$solution[1:3] #return goalkeeper strategy
  #if (sum(q_star) == 0) return(rep(NA, 7))
  q_star <- q_star / sum(q_star)
  v_star <- result$objval

  # Goalkeeper LP: min v such that A^T %*% p <= v, sum(p) = 1, p >= 0
  g.obj <- c(0, 0, 0, 1)
  g.con <- rbind(
    c(A[,1], -1),
    c(A[,2], -1),
    c(A[,3], -1),
    c(1, 1, 1, 0)
  )
  g.dir <- c("<=", "<=", "<=", "==")
  g.rhs <- c(0, 0, 0, 1)
  result2 <- lp("min", g.obj, g.con, g.dir, g.rhs)
  #if (result2$status != 0 || is.null(result2$solution)) return(rep(NA, 7))
  p_star <- result2$solution[1:3] #return kicker strategy
  #if (sum(p_star) == 0) return(rep(NA, 7))
  p_star <- p_star / sum(p_star)

  return(c(p_star, q_star, v_star))
}

a_vals <- seq(0.0, 0.5, length.out = 8)
e_vals <- seq(0.0, 0.5, length.out = 8)
b_vals <- seq(0.5, 1.0, length.out = 8)
c_vals <- seq(0.5, 1.0, length.out = 8)
d_vals <- seq(0.5, 1.0, length.out = 8)

#EXPAND GRID
param_grid <- expand.grid(a = a_vals, b = b_vals, c = c_vals, d = d_vals, e = e_vals) 

results <- data.frame()

for (i in 1:nrow(param_grid)) {
  a <- param_grid$a[i]
  b <- param_grid$b[i]
  c <- param_grid$c[i]
  d <- param_grid$d[i]
  e <- param_grid$e[i]
  
  # Construct symmetric matrix without noise
  A <- matrix(c(
    a, b, c,
    d, e, d,
    c, b, a
  ), nrow = 3, byrow = TRUE)
  
  out <- solve_penalty_game(A)

  results <- rbind(results, data.frame(
    a = a, b = b, c = c, d = d, e = e,
    pL = out[1], pC = out[2], pR = out[3],
    qL = out[4], qC = out[5], qR = out[6],
    v = out[7]
  ))
}

library(PNWColors)
library(ggplot2)
pal = pnw_palette("Bay",100,type="continuous")
ggplot(results, aes(x = d, y = e, fill = pC)) +
  geom_tile() +
  scale_fill_gradientn(colours = pal)

  labs(
    title = "Equilibrium probability of shooting Center",
    x = "d (off-center payoff)",
    y = "e (center payoff)"
  ) +
  theme_minimal()

NULL

3D heat map based on a, d, c probability

plotly_colorscale <- lapply(0:99, function(i) {
  list(i / 99, pal[i + 1])
})

plot_ly(
  data = results,
  x = ~a, y = ~d, z = ~c, color = ~qL, type = "scatter3d", mode = "markers",
  marker = list(size = 3, colorscale = plotly_colorscale, colorbar = list(title = "q*_L")),
  showscale = TRUE
) %>%
  layout(
    title = "Goalkeeper's equilibrium probability of diving Left (q*_L)",
    scene = list(
      xaxis = list(title = "a"),
      yaxis = list(title = "d"),
      zaxis = list(title = "c")
    )
  )

Warning :'scatter3d' objects don't have these attributes: 'showscale'
Valid attributes include:
'connectgaps', 'customdata', 'customdatasrc', 'error_x', 'error_y', 'error_z', 'hoverinfo', 'hoverinfosrc', 'hoverlabel', 'hovertemplate', 'hovertemplatesrc', 'hovertext', 'hovertextsrc', 'ids', 'idssrc', 'legendgroup', 'legendgrouptitle', 'legendrank', 'line', 'marker', 'meta', 'metasrc', 'mode', 'name', 'opacity', 'projection', 'scene', 'showlegend', 'stream', 'surfaceaxis', 'surfacecolor', 'text', 'textfont', 'textposition', 'textpositionsrc', 'textsrc', 'texttemplate', 'texttemplatesrc', 'transforms', 'type', 'uid', 'uirevision', 'visible', 'x', 'xcalendar', 'xhoverformat', 'xsrc', 'y', 'ycalendar', 'yhoverformat', 'ysrc', 'z', 'zcalendar', 'zhoverformat', 'zsrc', 'key', 'set', 'frame', 'transforms', '_isNestedKey', '_isSimpleKey', '_isGraticule', '_bbox'

Warning :'scatter3d' objects don't have these attributes: 'showscale'
Valid attributes include:
'connectgaps', 'customdata', 'customdatasrc', 'error_x', 'error_y', 'error_z', 'hoverinfo', 'hoverinfosrc', 'hoverlabel', 'hovertemplate', 'hovertemplatesrc', 'hovertext', 'hovertextsrc', 'ids', 'idssrc', 'legendgroup', 'legendgrouptitle', 'legendrank', 'line', 'marker', 'meta', 'metasrc', 'mode', 'name', 'opacity', 'projection', 'scene', 'showlegend', 'stream', 'surfaceaxis', 'surfacecolor', 'text', 'textfont', 'textposition', 'textpositionsrc', 'textsrc', 'texttemplate', 'texttemplatesrc', 'transforms', 'type', 'uid', 'uirevision', 'visible', 'x', 'xcalendar', 'xhoverformat', 'xsrc', 'y', 'ycalendar', 'yhoverformat', 'ysrc', 'z', 'zcalendar', 'zhoverformat', 'zsrc', 'key', 'set', 'frame', 'transforms', '_isNestedKey', '_isSimpleKey', '_isGraticule', '_bbox'

n_points <- 5  # control resolution (adjust for speed vs granularity)
vals_01 <- seq(0.0, 0.5, length.out = n_points)
vals_05 <- seq(0.5, 1.0, length.out = n_points)

# Grid for a, b, c, d, e, f, g, h
grid_raw <- expand.grid(
  a = vals_01,
  b = vals_05,
  c = vals_05,
  d = vals_05,
  e = vals_01,
  f = vals_05,
  g = vals_05,
  h = vals_01
)

param_grid2 <- grid_raw %>%
  filter(a > h, b > g, c > f)

results2 <- data.frame()

for (i in 1:nrow(param_grid2)) {
  a <- param_grid2$a[i]
  b <- param_grid2$b[i]
  c <- param_grid2$c[i]
  d <- param_grid2$d[i]
  e <- param_grid2$e[i]
  f <- param_grid2$f[i]
  g <- param_grid2$g[i]
  h <- param_grid2$h[i]
  
  # Construct symmetric matrix without noise
  A <- matrix(c(
    a, b, c,
    d, e, d,
    f, g, h
  ), nrow = 3, byrow = TRUE)
  
  out <- solve_penalty_game(A)

  results2 <- rbind(results2, data.frame(
    a = a, b = b, c = c, d = d, e = e, f = f, g = g, h = h,
    pL = out[1], pC = out[2], pR = out[3],
    qL = out[4], qC = out[5], qR = out[6],
    v = out[7]
  ))
}

ggplot(results2, aes(x = d, y = e, fill = pC)) +
  geom_tile() +
  scale_fill_gradientn(colours = pal)

  labs(
    title = "Equilibrium probability of shooting Center",
    x = "d (off-center payoff)",
    y = "e (center payoff)"
  ) +
  theme_minimal()

NULL

plot_ly(
  data = results2,
  x = ~a, y = ~d, z = ~c, color = ~qL, type = "scatter3d", mode = "markers",
  marker = list(size = 3, colorscale = plotly_colorscale, colorbar = list(title = "q*_L")),
  showscale = TRUE
) %>%
  layout(
    title = "Goalkeeper's equilibrium probability of diving Left (q*_L)",
    scene = list(
      xaxis = list(title = "a"),
      yaxis = list(title = "d"),
      zaxis = list(title = "c")
    )
  )

Warning :'scatter3d' objects don't have these attributes: 'showscale'
Valid attributes include:
'connectgaps', 'customdata', 'customdatasrc', 'error_x', 'error_y', 'error_z', 'hoverinfo', 'hoverinfosrc', 'hoverlabel', 'hovertemplate', 'hovertemplatesrc', 'hovertext', 'hovertextsrc', 'ids', 'idssrc', 'legendgroup', 'legendgrouptitle', 'legendrank', 'line', 'marker', 'meta', 'metasrc', 'mode', 'name', 'opacity', 'projection', 'scene', 'showlegend', 'stream', 'surfaceaxis', 'surfacecolor', 'text', 'textfont', 'textposition', 'textpositionsrc', 'textsrc', 'texttemplate', 'texttemplatesrc', 'transforms', 'type', 'uid', 'uirevision', 'visible', 'x', 'xcalendar', 'xhoverformat', 'xsrc', 'y', 'ycalendar', 'yhoverformat', 'ysrc', 'z', 'zcalendar', 'zhoverformat', 'zsrc', 'key', 'set', 'frame', 'transforms', '_isNestedKey', '_isSimpleKey', '_isGraticule', '_bbox'

Warning :'scatter3d' objects don't have these attributes: 'showscale'
Valid attributes include:
'connectgaps', 'customdata', 'customdatasrc', 'error_x', 'error_y', 'error_z', 'hoverinfo', 'hoverinfosrc', 'hoverlabel', 'hovertemplate', 'hovertemplatesrc', 'hovertext', 'hovertextsrc', 'ids', 'idssrc', 'legendgroup', 'legendgrouptitle', 'legendrank', 'line', 'marker', 'meta', 'metasrc', 'mode', 'name', 'opacity', 'projection', 'scene', 'showlegend', 'stream', 'surfaceaxis', 'surfacecolor', 'text', 'textfont', 'textposition', 'textpositionsrc', 'textsrc', 'texttemplate', 'texttemplatesrc', 'transforms', 'type', 'uid', 'uirevision', 'visible', 'x', 'xcalendar', 'xhoverformat', 'xsrc', 'y', 'ycalendar', 'yhoverformat', 'ysrc', 'z', 'zcalendar', 'zhoverformat', 'zsrc', 'key', 'set', 'frame', 'transforms', '_isNestedKey', '_isSimpleKey', '_isGraticule', '_bbox'